#lang racket


(require "../ast/main.rkt"
         "../backends/main.rkt"
         "../base/main.rkt"
         "../geometry/main.rkt"
         (prefix-in par: "../parametrization/main.rkt")
         "../proxies/main.rkt")

(require (prefix-in com: "rh-com.rkt")
         "rh-global.rkt"
         (prefix-in rscript: "rh-rhinoscript.rkt"))

(provide
 ; rhino
 (rename-out
  (com:load-rhino-com load-rhino-methods)
  
  (com:clear-command-history clear-command-history)
  (com:enable-redraw enable-redraw)
  (is-object? valid-shape?))
 
 ;; layer utils
 (rename-out (com:current-layer current-layer))
 ensure-layer
 
 replace-defers
 
 ; shapes
 bbox
 
 ; points
 (rename-out
  (add-point point)
  (is-point? point?)
  (point-coordinates point-c))
 
 ; lines
 arc
 elliptical-arc
 ellipse
 line
 spline
 
 (rename-out
  (is-curve? line?)
  (is-curve-closed? line-closed?)
  
  (curve-start-point line-begin-c)
  (curve-end-point line-end-c))
 
 ; surfaces
 ngon
 surface
 
 surface?
 
 surface-curvature
 surface-domain
 
 ; solids
 box
 cone
 cone-frustum
 cylinder
 pyramid
 sphere
 
 (rename-out (is-object-solid? solid?))
 
 ; generic shapes
 circle
 rectangle
 
 ; text
 text
 
 ; transformations 
 extrude
 intersect
 (rename-out (join-curves join))
 loft
 move
 rotate
 scale
 section
 (rename-out (split-brep slice))
 subtract
 sweep
 union
 thicken
 
 ; lang
 par
 
 ; cad
 (rename-out
  (copy-object clone-shape)
  (copy-objects clone-shapes)
  (delete-object delete-shape))
 delete-shapes
 (rename-out (all-objects get-shapes))
 prompt-point
 prompt-shape
 render-shapes
 (rename-out
  (select-object select-shape)
  (select-objects select-shapes)
  (com:unselect-all-objects unselect-all-shapes))
 view)


; exception

(define line-msg
  "Warning: Line: Rhino cannot make an open curve/polycurve with equal start and end coord; a close curve will be created instead")


; rhino id

(struct string-id id (str)
  #:constructor-name new-string-id
  #:transparent)

(define (make-string-id str)
  (unless (string? str)
    (raise-type-error 'make-string-id "string" str))
  (new-string-id str))


(struct list-id id (ids)
  #:constructor-name new-list-id
  #:transparent)

(define (make-list-id ids)
  (unless (andmap id? ids)
    (raise-type-error 'make-list-id "all strings" ids))
  (new-list-id ids))


(define (make-rhino-id str/strs)
  (cond ((string? str/strs)
         (make-string-id str/strs))
        ((empty? str/strs)
         (empty-id))
        ((singleton? str/strs)
         (make-string-id (first str/strs)))
        (else
         (make-list-id (map make-string-id str/strs)))))


(define (strs<-id id)
  (match id
    ((string-id str) (list str))
    ((list-id ids) (map strs<-id ids))
    ((defer-intersect id1 id2) (list (strs<-id id1) (strs<-id id2)))
    ((defer-subtract id1 id2) (list (strs<-id id1) (strs<-id id2)))
    ((defer-union id1 id2) (list (strs<-id id1) (strs<-id id2)))))

(define (flat-strs<-id id)
  (flatten (strs<-id id)))

(define (flat-strs<-ids ids)
  (flatten (map strs<-id ids)))

(define (flat-strs<-id/ids id/ids)
  (if (list? id/ids)
      (flat-strs<-ids id/ids)
      (flat-strs<-id id/ids)))


(struct defer-id id ()
  #:transparent)

(struct defer-intersect defer-id (id1 id2)
  #:transparent)

(struct defer-subtract defer-id (id1 id2)
  #:transparent)

(struct defer-union defer-id (id1 id2)
  #:transparent)


(define (id-dispatch id1 id2 shape-shape-fn shape-defer-fn defer-shape-fn defer-defer-fn)
  (cond ((and (defer-id? id1) (defer-id? id2)) defer-defer-fn)
        ((defer-id? id1) defer-shape-fn)
        ((defer-id? id2) shape-defer-fn)
        (else shape-shape-fn)))

; edit: bounding-box test is not enough; use intersection?
; : id -> id
(define (replace-defer id)
  (match id
    ((empty-id) id)
    ((universal-id) id)
    ((string-id _) id)
    ((list-id _) id)
    ((defer-intersect shape1 shape2)
     (let ((id1 (replace-defer shape1))
           (id2 (replace-defer shape2)))
       (cond ((and (empty-id? id1) (empty-id? id2))
              (empty-id))
             ((empty-id? id1)
              (delete-object id2)
              id1)
             ((empty-id? id2)
              (delete-object id1)
              id2)
             ((contained? id2 id1)
              (delete-object id1)
              id2)
             ((contained? id1 id2)
              (delete-object id2)
              id1)
             (else
              (delete-object id1)
              (delete-object id2)
              (empty-id)))))
    ((defer-subtract shape1 shape2)
     (let ((id1 (replace-defer shape1))
           (id2 (replace-defer shape2)))
       (cond ((and (empty-id? id1) (empty-id? id2))
              (empty-id))
             ((empty-id? id1)
              (delete-object id2)
              (empty-id))
             ((empty-id? id2)
              id1)
             ((contained? id2 id1)
              (delete-object id2)
              id1)
             ((contained? id1 id2)
              (delete-object id1)
              (delete-object id2)
              (empty-id))
             (else     
              (delete-object id2)
              id1))))
    ((defer-union shape1 shape2)
     (let ((id1 (replace-defer shape1))
           (id2 (replace-defer shape2)))
       (cond ((and (empty-id? id1) (empty-id? id2))
              (empty-id))
             ((empty-id? id1)
              id2)
             ((empty-id? id2)
              id1)
             (else
              (make-list-id (list id1 id2))))))))

; : shape -> shape
(define (replace-shape-defer shape)
  (let ((replaced-shape
         (match shape
           ((simple-shape _ _ id) (make-simple-shape (replace-defer id)))
           ((list-shape _ _ shapes) (make-list-shape (map replace-shape-defer shapes))))))
    (set-shape-backend! replaced-shape (shape-backend shape))
    (set-shape-node! replaced-shape (shape-node shape))
    replaced-shape))

; : shape/expr -> shape/expr
(define (replace-defers shape/expr)
  (cond ((rhino-replace-defer?)
         (cond ((shape? shape/expr)
                (replace-shape-defer shape/expr))
               (else
                shape/expr)))
        (else
         shape/expr)))

; /defer


; rhino

(define (add-edge-srf id)
  (begin0
    (match id
      ((list-id ids)
       (make-string-id (com:add-edge-srf (flat-strs<-ids ids)))))
    (delete-objects id)))

(define (add-hatch id)
  (begin0
    (match id
      ((string-id str)
       (make-string-id (com:add-hatch str))))
    (delete-object id)))

(define (add-interp-curve coords . args)
  (make-string-id (apply com:add-interp-curve coords args)))

(define (add-loft-surface ids . args)
  (begin0
    (make-rhino-id (apply com:add-loft-srf (flat-strs<-ids ids) args))
    (delete-objects ids)))

(define (add-planar-srf id)
  (begin0
    (match id
      ((string-id str)
       (make-rhino-id (com:add-planar-srf (list str))))
      ((list-id ids)
       (make-rhino-id (com:add-planar-srf (flat-strs<-ids ids)))))
    (delete-object id)))

(define (add-point c)
  (make-string-id (com:add-point c)))

(define (add-polyline coords)
  (make-string-id (com:add-polyline coords)))

(define (add-srf-section-crvs id plane)
  (begin0
    (match id
      ((string-id str)
       (make-rhino-id (com:add-srf-section-crvs str plane))))
    (delete-object id)))

(define (all-objects)
  (map make-string-id (com:all-objects)))

(define (boolean-difference id1 id2)
  (with-handlers ((com:com-exn? (λ (e) (defer-subtract id1 id2))))
    (match (cons id1 id2)
      ((cons (empty-id) _)
       (delete-object id2)
       id1)
      ((cons _ (empty-id))
       id1)
      ((cons (universal-id) _)
       (error 'boolean-difference "Symmetric not implemented"))
      ((cons _ (universal-id))
       (delete-object id1)
       (empty-id))
      (_
       (make-rhino-id
        (com:boolean-difference
         (flat-strs<-id id1)
         (flat-strs<-id id2)))))))

(define (boolean-intersection id1 id2)
  (with-handlers ((com:com-exn? (λ (e) (defer-intersect id1 id2))))
    (match (cons id1 id2)
      ((cons (empty-id) _)
       (delete-object id2)
       id1)
      ((cons _ (empty-id))
       (delete-object id1)
       id2)
      ((cons (universal-id) _)
       id2)
      ((cons _ (universal-id))
       id1)
      (_
       (make-rhino-id
        (com:boolean-intersection
         (flat-strs<-id id1)
         (flat-strs<-id id2)))))))

(define (boolean-union id1 id2)
  (with-handlers ((com:com-exn? (λ (e) (defer-union id1 id2))))
    (match (cons id1 id2)
      ((cons (empty-id) _)
       id1)
      ((cons _ (empty-id))
       id2)
      ((cons (universal-id) _)
       id1)
      ((cons _ (universal-id))
       id2)
      (_
       (make-rhino-id
        (com:boolean-union
         (flat-strs<-ids (list id1 id2))))))))

(define (bounding-box id/ids)
  (com:bounding-box (flat-strs<-id/ids id/ids)))

(define (cap-planar-holes id)
  (begin0
    id
    (match id
      ((string-id str)
       (com:cap-planar-holes str))
      ((list-id ids)
       (for-each com:cap-planar-holes (flat-strs<-ids ids))))))

(define (close-curve id)
  (match id
    ((string-id str)
     (make-string-id (com:close-curve str)))))

(define (copy-object id)
  (match id
    ((string-id str)
     (make-string-id (com:copy-object str)))
    ((list-id ids)
     (make-list-id (map copy-object ids)))
    ((defer-intersect id1 id2)
     (defer-intersect (copy-object id1) (copy-object id2)))
    ((defer-subtract id1 id2)
     (defer-subtract (copy-object id1) (copy-object id2)))
    ((defer-union id1 id2)
     (defer-union (copy-object id1) (copy-object id2)))))

(define (copy-objects ids)
  (map copy-object ids))

; info: true if 'shape1' is contained inside 'shape2'
; edit: this is not always correct: an object can be inside another's bounding-box without
; intersecting it and still that object is not contained in the other
(define (contained? id1 id2)
  (and
   (is-object-in-box? id1 (bounding-box id2))
   (not (intersect? id1 id2))))

(define (circle-center-point id)
  (match id
    ((string-id str)
     (com:circle-center-point str))))

(define (circle-radius id)
  (match id
    ((string-id str)
     (com:circle-radius str))))

(define (curve-boolean-difference id1 id2)
  (match (cons id1 id2)
    ((cons (string-id str1) (string-id str2))
     (begin0
       (make-rhino-id
        (com:curve-boolean-difference str1 str2))
       (delete-object id1)
       (delete-object id2)))))

(define (curve-boolean-intersection id1 id2)
  (match (cons id1 id2)
    ((cons (string-id str1) (string-id str2))
     (begin0
       (make-rhino-id
        (com:curve-boolean-intersection str1 str2))
       (delete-object id1)
       (delete-object id2)))))

(define (curve-boolean-union id1 id2)
  (begin0
    (make-rhino-id
     (com:curve-boolean-union (flat-strs<-ids (list id1 id2))))
    (delete-object id1)
    (delete-object id2)))

(define (curve-end-point id)
  (match id
    ((string-id str)
     (com:curve-end-point str))))

(define (curve-normal id)
  (match id
    ((string-id str)
     (com:curve-normal str))))

(define (curve-start-point id)
  (match id
    ((string-id str)
     (com:curve-start-point str))))

(define (delete-object id)
  (match id
    ((empty-id) (void))
    ((universal-id) (void))
    ((string-id str)
     (com:delete-object str))
    ((list-id ids)
     (com:delete-objects (flat-strs<-ids ids)))
    ((defer-intersect id1 id2)
     (com:delete-objects (flat-strs<-ids (list id1 id2))))
    ((defer-subtract id1 id2)
     (com:delete-objects (flat-strs<-ids (list id1 id2))))
    ((defer-union id1 id2)
     (com:delete-objects (flat-strs<-ids (list id1 id2))))))

(define (delete-objects ids)
  (com:delete-objects (flat-strs<-ids ids)))

(define (duplicate-edge-curves id)
  (begin0
    (match id
      ((string-id str)
       (make-rhino-id (com:duplicate-edge-curves str #f))))
    (delete-object id)))

(define (duplicate-surface-border id)
  (begin0
    (match id
      ((string-id str)
       (make-rhino-id (com:duplicate-surface-border str))))
    (delete-object id)))

(define (ensure-layer name)
  (if (com:is-layer? name)
      name
      (com:add-layer name)))

(define (extrude-curve id path-id)
  (begin0
    (match (cons id path-id)
      ((cons (string-id str) (string-id path-str))
       (make-string-id (com:extrude-curve str path-str))))
    (delete-object id)))

(define (extrude-curve-point id c)
  (begin0
    (match id
      ((string-id str)
       (make-string-id (com:extrude-curve-point str c))))
    (delete-object id)))

(define (extrude-curve-straight id start-c end-c)
  (begin0
    (match id
      ((string-id str)
       (make-string-id (com:extrude-curve-straight str start-c end-c))))
    (delete-object id)))

(define (extrude-surface id curve-id cap?)
  (begin0
    (match (cons id curve-id)
      ((cons (string-id str) (string-id curve-str))
       (make-string-id (com:extrude-surface str curve-str cap?))))
    (delete-object id)))

(define (intersect? id1 id2)
  (let ((copy1 (copy-object id1))
        (copy2 (copy-object id2)))
    (let ((res (intersect-impl copy1 copy2)))
      (cond ((defer-id? res)
             (delete-object copy1)
             (delete-object copy2)
             #f)
            (else
             (delete-object res)
             #t)))))

(define (intersect-breps id1 id2 . args)
  (with-handlers ((com:com-exn? (λ (e) (defer-intersect id1 id2))))
    (match (cons id1 id2)
      ((cons (empty-id) _)
       (delete-object id2)
       id1)
      ((cons _ (empty-id))
       (delete-object id1)
       id2)
      ((cons (universal-id) _)
       id2)
      ((cons _ (universal-id))
       id1)
      ((cons (string-id str1) (string-id str2))
       (begin0
         (make-rhino-id (apply com:intersect-breps str1 str2 args))
         (delete-object id1)
         (delete-object id2))))))

(define (is-circle? id)
  (and
   (string-id? id)
   (com:is-circle? (string-id-str id))))

(define (is-curve? id)
  (and
   (string-id? id)
   (com:is-curve? (string-id-str id))))

(define (is-curve-closable? id)
  (and
   (string-id? id)
   (com:is-curve-closable? (string-id-str id))))

(define (is-curve-closed? id)
  (and
   (string-id? id)
   (is-curve? id)
   (com:is-curve-closed? (string-id-str id))))

(define (is-object? id)
  (com:is-object? (string-id-str id)))

(define (is-object-in-box? id bb)
  (match id
    ((string-id str)
     (com:is-object-in-box? str bb))
    ((list-id ids)
     (andmap (λ (str) (com:is-object-in-box? str bb)) (flat-strs<-ids ids)))))

(define (is-object-solid? id)
  (and
   (string-id? id)
   (com:is-object-solid? (string-id-str id))))

(define (is-point? id)
  (and
   (string-id? id)
   (com:is-point? (string-id-str id))))

(define (is-surface? id)
  (and
   (string-id? id)
   (com:is-surface? (string-id-str id))))

(define (join-curves ids)
  (make-rhino-id (com:join-curves (flat-strs<-ids ids) #t)))

(define layer=? string=?)

(define (move-object id position)
  (match id
    ((string-id str)
     (make-string-id (com:move-object str position)))
    ((list-id ids)
     (make-list-id (map (λ (id) (move-object id position)) ids)))
    ((defer-intersect id1 id2)
     (defer-intersect
       (move-object id1 position)
       (move-object id2 position)))
    ((defer-subtract id1 id2)
     (defer-subtract
       (move-object id1 position)
       (move-object id2 position)))     
    ((defer-union id1 id2)
     (defer-union
       (move-object id1 position)
       (move-object id2 position)))))

(define (move-objects ids position)
  (map (λ (id) (move-object id position)) ids))

(define (offset-surface id distance)
  (begin0
    (match id
      ((string-id str)
       (make-string-id (com:offset-surface str distance))))
    (delete-object id)))

(define (point-coordinates id)
  (match id
    ((string-id str)
     (com:point-coordinates str))))

(define (rotate-object id point angle axis copy?)
  (match id
    ((string-id str)
     (make-string-id (com:rotate-object str point angle axis copy?)))
    ((list-id ids)
     (make-list-id (map (λ (id) (rotate-object id point angle axis copy?)) ids)))
    ((defer-intersect id1 id2)
     (defer-intersect
       (rotate-object id1 point angle axis copy?)
       (rotate-object id2 point angle axis copy?)))
    ((defer-subtract id1 id2)
     (defer-subtract
       (rotate-object id1 point angle axis copy?)
       (rotate-object id2 point angle axis copy?)))
    ((defer-union id1 id2)
     (defer-union
       (rotate-object id1 point angle axis copy?)
       (rotate-object id2 point angle axis copy?)))))

(define (rotate-objects ids point angle axis copy?)
  (map (λ (id) (rotate-object id point angle axis copy?)) ids))

(define (scale-object id origin scale (copy? #f))
  (match id
    ((string-id str)
     (make-string-id (com:scale-object str origin scale copy?)))
    ((list-id ids)
     (make-list-id (map (λ (id) (scale-object id origin scale copy?)) ids)))
    ((defer-intersect id1 id2)
     (defer-intersect
       (scale-object id1 origin scale)
       (scale-object id2 origin scale)))
    ((defer-subtract id1 id2)
     (defer-subtract
       (scale-object id1 origin scale)
       (scale-object id2 origin scale)))
    ((defer-union id1 id2)
     (defer-union
       (scale-object id1 origin scale)
       (scale-object id2 origin scale)))))

(define (scale-objects ids origin scale (copy? #f))
  (map (λ (id) (scale-object id origin scale copy?)) ids))

(define (select-object id)
  (begin0
    id
    (match id
      ((string-id str)
       (com:select-object str))
      ((list-id ids)
       (com:select-objects (flat-strs<-ids ids)))
      ((defer-intersect id1 id2)
       (com:select-objects (flat-strs<-ids (list id1 id2))))
      ((defer-subtract id1 id2)
       (com:select-objects (flat-strs<-ids (list id1 id2))))
      ((defer-union id1 id2)
       (com:select-objects (flat-strs<-ids (list id1 id2)))))))

(define (select-objects ids)
  (begin0
    ids
    (com:select-objects (flat-strs<-ids ids))))

(define (select id/ids)
  (if (list? id/ids)
      (select-objects id/ids)
      (select-object id/ids)))

(define (selected-objects)
  (map make-string-id (com:selected-objects)))

(define (surface-curvature id uv)
  (match id
    ((string-id str)
     (com:surface-curvature str uv))))

(define (surface-domain id direction)
  (match id
    ((string-id str)
     (com:surface-domain id direction))))

(define (split-brep id cutter)
  (begin0
    (match (cons id cutter)
      ((cons (string-id str) (string-id cutter-str))
       (map make-string-id (com:split-brep str cutter-str #t))))
    (delete-object cutter)))


; shapes

(define (bbox id)
  (begin0
    (bounding-box id)
    (delete-object id)))


; lines

(define (arc angle radius)
  (make-string-id
   (com:add-arc (com:world-xy-plane) radius (degrees<-radians angle))))

(define (elliptical-arc angle x-radius y-radius)
  (scale (origin-scaling-type) (xyz x-radius y-radius 1) (arc angle 1)))

(define (ellipse x-radius y-radius)
  (make-string-id
   (com:add-ellipse (com:world-xy-plane) x-radius y-radius)))

(define (line closed? coords)
  (define (open-line)
    (when (eq-c (first coords) (last coords))
      (displayln line-msg))
    (add-polyline coords))
  
  (define (closed-line)
    (let ((id (add-polyline coords)))
      (cond ((is-curve-closed? id)
             id)
            ((is-curve-closable? id)
             (close-curve id))
            (else
             (delete-object id)
             (add-polyline (append-first coords))))))
  
  (if closed?
      (closed-line)
      (open-line)))

(define (spline closed? cs type)
  (match type
    ((auto-spline-type)
     (if closed?
         (add-interp-curve (append-first cs))
         (add-interp-curve cs)))
    ((tangent-spline-type begin-tangent end-tangent)
     (let ((cs (if closed? (append-first cs) cs)))
       (add-interp-curve cs 3 com:knot-style-uniform-knots begin-tangent end-tangent)))))


; surfaces

(define (ngon type width sides)
  (if (= sides 4)
      (rectangle type width width)
      (error 'ngon "Only 4-sided ngons are implemented")))


; surface

(define (surface-from-list lst)
  (cond
    ((andmap is-coord lst)
     (make-string-id (com:add-srf-pt lst)))
    ((andmap is-curve? lst)
     (add-edge-srf (make-list-id lst)))
    (else
     (error 'surface "Unhandled shape"))))

(define (surface id/ids)
  (cond ((list? id/ids)
         (surface-from-list id/ids))
        ((is-curve-closed? id/ids)
         (add-planar-srf id/ids))
        ; edit: hack or correct? perhaps introduce the concept of polysurface
        (else
         (add-edge-srf (list id/ids)))))

; /surface


(define (surface? id)
  (and
   (is-surface? id)
   (not (is-object-solid? id))))


; solids

(define (box width length height)
  (make-string-id
   (com:add-box
    (flatten (map list-of-coord (box-corners width length height))))))

(define (cone radius height)
  (make-string-id
   (com:add-cone
    u0
    (mult-c uz height)
    radius
    true)))

(define (cone-frustum base-radius top-radius height)
  (loft
   (solid-loft-type)
   (ruled-loft-fit-type)
   #f
   (list (circle u0 (line-primitive-type) base-radius)
         (circle (z height) (line-primitive-type) top-radius))))

(define (cylinder radius height)
  (make-string-id
   (com:add-cylinder u0 (mult-c uz height) radius true)))

(define (pyramid width sides height)
  (cap-planar-holes
   (extrude-curve-point (ngon (line-primitive-type) width sides) (z height))))

(define (sphere radius)
  (make-string-id
   (com:add-sphere u0 radius)))


; generic shapes

; edit: use plane instead of move?
(define (circle c type radius)
  (match type
    ((line-primitive-type)
     (move
      c
      (make-string-id
       (com:add-circle (com:world-xy-plane) radius))))
    ((surface-primitive-type)
     (add-planar-srf (circle c (line-primitive-type) radius)))))

(define (rectangle type width length)
  (match type
    ((line-primitive-type)
     (line #t
           (let ((width (/ width 2))
                 (length (/ length 2)))
             (list
              (xyz (- width) (- length) 0)
              (xyz width (- length) 0)
              (xyz width length 0)
              (xyz (- width) length 0)))))
    ((surface-primitive-type)
     (surface (rectangle (line-primitive-type) width length)))))


; text

; edit: missing rotation
(define (text t r s str)
  (move
   t
   (scale
    (origin-scaling-type)
    s
    (make-rhino-id (com:add-text str (com:world-xy-plane))))))

; transformations

(define (extrude length dir id)
  (define (extrude-curve-impl id)
    (let ((lengthed-dir (mult-c (norm dir) length)))
      (extrude-curve-straight id u0 lengthed-dir)))
  
  (define (extrude-surface-impl id)
    (cap-planar-holes
     (extrude-curve-impl
      (duplicate-surface-border id))))
  
  (if (is-curve? id)
      (extrude-curve-impl id)
      (extrude-surface-impl id)))


; intersect


; A /\ B
; info: is-surface? recognizes both surfaces and solids
(define (intersect.id/id id1 id2)
  (cond ((and (is-object-solid? id1) (is-object-solid? id2))
         (boolean-intersection id1 id2))
        ((and (is-surface? id1) (is-surface? id2))
         (add-planar-srf (intersect-breps id1 id2)))
        ((and (is-curve-closed? id1) (is-curve-closed? id2))
         (curve-boolean-intersection id1 id2))
        (else
         (boolean-intersection id1 id2))))

; A /\ d(B ? C)
(define (intersect.id/defer shape defer)
  (intersect.defer/id defer shape))

; d(A ? B) /\ C
(define (intersect.defer/id defer id)
  ; d(A /\ B) /\ C
  (define (intersect.defer-intersect/id a b c)
    ; = A /\ C /\ B
    (define (intersect1 a b c)
      (let ((a-copy (copy-object a))
            (c-copy (copy-object c)))
        (let ((val1 (intersect-impl a-copy c-copy)))
          (cond ((defer-intersect? val1)
                 (delete-object a-copy)
                 (delete-object c-copy)
                 (defer-intersect (defer-intersect a c) b))
                (else
                 (let ((val2 (intersect-impl val1 b)))
                   (cond ((defer-intersect? val2)
                          (delete-object val1)
                          (defer-intersect (defer-intersect a c) b))
                         (else
                          (delete-object a)
                          (delete-object c)
                          val2))))))))
    
    ; = B /\ C /\ A
    (define (intersect2 a b c)
      (let ((b-copy (copy-object b))
            (c-copy (copy-object c)))
        (let ((val1 (intersect-impl b-copy c-copy)))
          (cond ((defer-intersect? val1)
                 (delete-object b-copy)
                 (delete-object c-copy)
                 (defer-intersect (defer-intersect b c) a))
                (else
                 (let ((val2 (intersect-impl val1 a)))
                   (cond ((defer-intersect? val2)
                          (delete-object val1)
                          (defer-intersect (defer-intersect b c) a))
                         (else
                          (delete-object b)
                          (delete-object c)
                          val2))))))))
    
    (let ((val (intersect1 a b c)))
      (if (defer-intersect? val)
          (intersect2 a b c)
          val)))
  
  ; d(A - B) /\ C
  (define (intersect.defer-subtract/id a b c)
    (error 'intersect.defer-subtract/id "Not implemented"))
  
  ; d(A U B) /\ C
  (define (intersect.defer-union/id a b c)
    (error 'intersect.defer-union/id "Not implemented"))
  
  (match defer
    ((defer-intersect a b)
     (intersect.defer-intersect/id a b id))
    ((defer-subtract a b)
     (intersect.defer-subtract/id a b id))
    ((defer-union a b)
     (intersect.defer-union/id a b id))))

; d(A ? B) /\ d(C ? D)
(define (intersect.defer-defer defer1 defer2)
  (error 'intersect.defer-defer "Not implemented"))

(define (dispatch-defer-intersect id1 id2)
  (id-dispatch
   id1
   id2
   intersect.id/id
   intersect.id/defer
   intersect.defer/id
   intersect.defer-defer))

(define (intersect-impl id1 id2)
  ((dispatch-defer-intersect id1 id2) id1 id2))

(define (intersect ids)
  (reduce
   (λ (id2 id1) (intersect-impl id1 id2))
   ids))

; /intersect

; sweep

(define (sweep path shape)
  (let ((path-id (string-id-str path))
        (shape-id (strs<-id shape)))
    (let ((plane (com:curve-perp-frame path-id 0.0))
          (bbox (com:bounding-box shape-id)))
      (com:move-objects shape-id (mult-c (bbox-center bbox) -1))
      (com:transform-objects shape-id plane)
      (begin0
        (make-rhino-id
         (if (is-curve? shape)
             (com:sweep1 path-id shape-id)
             (cap-planar-holes
              (com:sweep1 path-id shape-id))))
        (delete-object path)))))


; /sweep

; loft

(define (loft-curves ids fit-type closed?)
  (add-loft-surface ids fit-type closed?))

(define (loft-surfaces ids fit-type closed?)
  (let ((borders (map duplicate-surface-border ids)))
    (loft-curves borders fit-type closed?)))

(define (cap-unless-closed? shape closed?)
  (if closed?
      shape
      (cap-planar-holes shape)))

(define (loft-curves-to-surface shapes fit-type closed?)
  (loft-curves shapes fit-type closed?))

(define (loft-curves-to-solid shapes fit-type closed?)
  (cap-unless-closed? (loft-curves shapes fit-type closed?) closed?))

(define (loft-surfaces-to-surface shapes fit-type closed?)
  (loft-surfaces shapes fit-type closed?))

(define (loft-surfaces-to-solid shapes fit-type closed?)
  (cap-unless-closed? (loft-surfaces shapes fit-type closed?) closed?))

(define (loft loft-type loft-fit-type closed? ids)
  (let ((fit-type
         (match loft-fit-type
           ((ruled-loft-fit-type) com:loft-type-straight)
           ((smooth-loft-fit-type) com:loft-type-normal))))
    (match loft-type
      ((auto-loft-type)
       (cond ((every is-curve? ids)
              (loft-curves-to-surface ids fit-type closed?))
             ((every is-surface? ids)
              (loft-surfaces-to-solid ids fit-type closed?))
             (else
              (error 'loft "Unhandled loft type"))))
      ((surface-loft-type)
       (cond ((every is-curve? ids)
              (loft-curves-to-surface ids fit-type closed?))
             ((every is-surface? ids)
              (loft-surfaces-to-surface ids fit-type closed?))
             (else
              (error 'loft "Unhandled loft type"))))
      ((solid-loft-type)
       (cond ((every is-curve? ids)
              (loft-curves-to-solid ids fit-type closed?))
             ((every is-surface? ids)
              (loft-surfaces-to-solid ids fit-type closed?))
             (else
              (error 'loft "Unhandled loft type")))))))

; /loft


(define (move position id/ids)
  (let ((move-fn (if (list? id/ids) move-objects move-object)))
    (move-fn id/ids position)))

(define (rotate angle normal id/ids)
  (let ((rotate-fn (if (list? id/ids) rotate-objects rotate-object)))
    (rotate-fn id/ids u0 (degrees<-radians angle) normal #f)))

(define (scale type size id/ids)
  (match type
    ((center-scaling-type)
     (error 'scale "Rhino scale: center not implemented"))
    ((origin-scaling-type)
     (let ((scale-fn (if (list? id/ids) scale-objects scale-object)))
       (scale-fn id/ids u0 size #f)))))

(define (section type plane id)
  (match type
    ((auto-section-type)
     (error 'add-srf-section-crvs "Rhino section: implemented only for lines"))
    ((line-section-type)
     (add-srf-section-crvs id plane))
    ((surface-section-type)
     (error 'add-srf-section-crvs "section is only implemented for lines"))))


; subtract

; A - B
(define (subtract.id/id id1 id2)
  (cond ((and (is-curve-closed? id1) (is-curve-closed? id2))
         (curve-boolean-difference id1 id2))
        (else
         (boolean-difference id1 id2))))

; A - d(B ? C)
(define (subtract.id/defer id defer)
  ; A - d(B /\ C)
  (define (subtract.id/defer-intersect a b c)
    (error 'subtract.id/defer-intersect "Not implemented"))
  
  ; A - d(B - C)
  ; = (A /\ C) U (A - B)
  (define (subtract.id/defer-subtract a b c)
    (let ((a-copy1 (copy-object a))
          (c-copy (copy-object c)))
      (let ((val1 (intersect-impl a-copy1 c-copy)))
        (cond ((defer-intersect? val1)
               (delete-object a-copy1)
               (delete-object c-copy)
               (defer-union
                 (defer-intersect a c)
                 (defer-subtract a b)))
              (else
               (let ((a-copy2 (copy-object a))
                     (b-copy (copy-object b)))
                 (let ((val2 (subtract-impl a-copy2 b-copy)))
                   (cond ((defer-subtract? val2)
                          (delete-object val1)
                          (delete-object a-copy2)
                          (delete-object b-copy)
                          (defer-union
                            (defer-intersect a c)
                            (defer-subtract a b)))
                         (else
                          (let ((val3 (union-impl val1 val2)))
                            (cond ((defer-union? val3)
                                   (delete-object val1)
                                   (delete-object val2)
                                   (defer-union
                                     (defer-intersect a c)
                                     (defer-subtract a b)))
                                  (else
                                   (delete-object a)
                                   (delete-object b)
                                   (delete-object c)
                                   val3))))))))))))
  
  ; A - d(B U C)
  (define (subtract.id/defer-union a b c)
    (error 'subtract.id/defer-union "Not implemented"))
  
  (match defer
    ((defer-intersect a b)
     (subtract.id/defer-intersect id a b))
    ((defer-subtract a b)
     (subtract.id/defer-subtract id a b))
    ((defer-union a b)
     (subtract.id/defer-union id a b))))

; d(A ? B) - C
(define (subtract.defer/id defer id)
  ; d(A /\ B) - C
  (define (subtract.defer-intersect/id a b c)
    (error 'subtract.defer-intersect/id "Not implemented"))
  
  ; d(A - B) - C
  ; = A - C - B
  (define (subtract.defer-subtract/id a b c)
    (let ((a-copy (copy-object a))
          (c-copy (copy-object c)))
      (let ((val1 (subtract-impl a-copy c-copy)))
        (cond ((defer-subtract? val1)
               (delete-object a-copy)
               (delete-object c-copy)
               (defer-subtract (defer-subtract a c) b))
              (else
               (let ((val2 (subtract-impl val1 b)))
                 (cond ((defer-subtract? val2)
                        (delete-object val1)
                        (defer-subtract (defer-subtract a c) b))
                       (else
                        (delete-object a)
                        (delete-object c)
                        val2))))))))
  
  ; d(A U B) - C
  (define (subtract.defer-union/id a b c)
    (error 'subtract.defer-union/id "Not implemented"))
  
  (match defer
    ((defer-intersect a b)
     (subtract.defer-intersect/id a b id))
    ((defer-subtract a b)
     (subtract.defer-subtract/id a b id))
    ((defer-union a b)
     (subtract.defer-union/id a b id))))

; d(A ? B) - d(C ? D)
(define (subtract.defer/defer defer1 defer2)
  (defer-subtract defer1 defer2))

(define (dispatch-defer-subtract id1 id2)
  (id-dispatch
   id1
   id2
   subtract.id/id
   subtract.id/defer
   subtract.defer/id
   subtract.defer/defer))

(define (subtract-impl id1 id2)
  ((dispatch-defer-subtract id1 id2) id1 id2))

(define (subtract ids)
  (reduce (λ (id2 id1) (subtract-impl id1 id2)) ids))

; /subtract


; union

; A U B
(define (union.shape-shape id1 id2)
  (cond ((and (is-curve-closed? id1) (is-curve-closed? id2))
         (curve-boolean-union id1 id2))
        (else
         (boolean-union id1 id2))))

; A U d(B ? C)
(define (union.shape-defer shape defer)
  (union.defer-shape defer shape))

; d(A ? B) U C
(define (union.defer-shape defer shape)
  ; d(A /\ B) U C
  (define (union.defer-intersect-shape a b c)
    (error 'union.defer-intersect-shape "Not implemented"))
  
  ; d(A - B) U C
  (define (union.defer-subtract-shape a b c)
    (error 'union.defer-subtract-shape "Not implemented"))
  
  ; d(A U B) U C
  (define (union.defer-union-shape a b c)
    ; = A U C U B
    (define (union1 a b c)
      (let ((a-copy (copy-object a))
            (c-copy (copy-object c)))
        (let ((val1 (union-impl a-copy c-copy)))
          (cond ((defer-union? val1)
                 (delete-object a-copy)
                 (delete-object c-copy)
                 (defer-union (defer-union a c) b))
                (else
                 (let ((val2 (union-impl val1 b)))
                   (cond ((defer-union? val2)
                          (delete-object val1)
                          (defer-union (defer-union a c) b))
                         (else
                          (delete-object a)
                          (delete-object c)
                          val2))))))))
    
    ; = B U C U A
    (define (union2 a b c)
      (let ((b-copy (copy-object b))
            (c-copy (copy-object c)))
        (let ((val1 (union-impl b-copy c-copy)))
          (cond ((defer-union? val1)
                 (delete-object b-copy)
                 (delete-object c-copy)
                 (defer-union (defer-union b c) a))
                (else
                 (let ((val2 (union-impl val1 a)))
                   (cond ((defer-union? val2)
                          (delete-object val1)
                          (defer-union (defer-union b c) a))
                         (else
                          (delete-object b)
                          (delete-object c)
                          val2))))))))
    
    (let ((val (union1 a b c)))
      (if (defer-union? val)
          (union2 a b c)
          val)))
  
  (match defer
    ((defer-intersect a b)
     (union.defer-intersect-shape a b shape))
    ((defer-subtract a b)
     (union.defer-subtract-shape a b shape))
    ((defer-union a b)
     (union.defer-union-shape a b shape))))

; d(A ? B) U d(C ? D)
(define (union.defer-defer defer1 defer2)
  (defer-union defer1 defer2))

(define (dispatch-defer-union shape1 shape2)
  (id-dispatch
   shape1
   shape2
   union.shape-shape
   union.shape-defer
   union.defer-shape
   union.defer-defer))

(define (union-impl shape1 shape2)
  ((dispatch-defer-union shape1 shape2) shape1 shape2))

(define (union shapes)
  (reduce
   (λ (shape2 shape1) (union-impl shape1 shape2))
   shapes))

; /union


(define (thicken distance id)
  (match id
    ((string-id str)
     (make-string-id
      (rscript:offset-surface-solid-command str distance)))))


; lang

; par

(define (par-circle shape)
  (let ((center (circle-center-point shape))
        (normal (curve-normal shape))
        (radius (circle-radius shape)))
    (let ((translation
           (apply m-translation (list-of-coord center)))
          (rotation
           (m-rotation (angle-c uz normal (cross-c uz normal)) (cross-c uz normal))))
      (par:make-transformation-parametric
       (par:make-transformation-parametric
        (par:make-circle-curve radius)
        rotation)
       translation))))

(define (par shape)
  (finally
   (cond ((is-circle? shape)
          (par-circle shape))
         (else
          (error 'par "Unhandled par type")))
   (λ () (delete-object shape))))

; /par


; cad

(define (delete-shapes)
  (delete-objects (all-objects))
  (com:clear-command-history)
  #;(rscript:clear-all-meshes-command))

(define (prompt-point message)
  (com:get-point message))

(define (prompt-shape message)
  (make-string-id (com:get-object message)))

(define (render-shapes width height path type)
  (match type
    ((draft-render-type)
     (com:create-preview-image path com:view-perspective (list width height)))))


; view

(define (set-view-projection! projection-type)
  (match projection-type
    ((ortho-projection-type)
     (com:view-projection com:view-perspective com:view-projection-mode-parallel))
    ((perspective-projection-type lens)
     (com:view-projection com:view-perspective com:view-projection-mode-perspective)
     (com:view-camera-lens com:view-perspective lens))))

(define (set-view-style! style)
  (let ((display-mode
         (match style
           ((wireframe-view-style) com:view-display-mode-wireframe)
           ((realistic-view-style) com:view-display-mode-render-preview))))
    (com:view-display-mode com:view-perspective display-mode)))

(define (auto-view direction projection-type style shape/shapes)
  (set-view-projection! projection-type)
  (com:view-camera-target com:view-perspective (mult-c direction -1) u0)
  (set-view-style! style)
  (let ((selected-objects (selected-objects)))
    (com:unselect-all-objects)
    (select shape/shapes)
    (com:zoom-selected com:view-perspective)
    (com:unselect-all-objects)
    (select selected-objects)))

(define (manual-view center target projection-type style)
  (set-view-projection! projection-type)
  (com:view-camera-target com:view-perspective center target)
  (set-view-style! style))

(define (view type projection-type style shape/shapes)
  (begin0
    shape/shapes
    (match type
      ((auto-view-type direction)
       (auto-view direction projection-type style shape/shapes))
      ((manual-view-type center target)
       (manual-view center target projection-type style)))))

; /view